home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / f2c-stab.9 / f2c-stab / f2c-stabs / si-fstabs-lib.stk < prev    next >
Encoding:
Text File  |  1996-03-31  |  4.7 KB  |  155 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;; si-fstabs-lib - Library for generating f2c-stabs emacs files from
  3. ;;;                 si info. 
  4. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  5. ;;;
  6. ;;; Copyright (c) 1996 Harvey J. Stein <abel@netvision.net.il>, and
  7. ;;; eventually <hjstein@netvision.net.il>
  8. ;;; All Rights Reserved.
  9. ;;; 
  10. ;;; This package is covered by the GNU GPL.  You can freely use and
  11. ;;; distribute it as long as it stays under the GNU GPL, and as long as
  12. ;;; you distribute all the corresponding source code, and as long as this
  13. ;;; message and the above copyright notice remains.
  14.  
  15. (require "si-lib")
  16.  
  17. (define (build-and-add-f2c-stab-data si-decl)
  18.   (with-output-to-file (format #f "| cat >>~a" (sif2c-file-name si-decl))
  19.     (lambda () (si2f2c-stab si-decl))))
  20.  
  21. (define (sif2c-file-name si-decl)
  22.   (string-append (symbol->string (si-filename si-decl))
  23.          ".el"))
  24.  
  25. (define (inc->req s)
  26.   (if (symbol? s) s
  27.       (string->symbol s)))
  28.  
  29. ;;  (define suff (string->regexp "^(.*)\\.(.*)$"))
  30. ;;  (apply substring s (list-ref (suff s) 1))
  31.  
  32. (define (sif2c-mangle-subname sub)
  33.   (set! sub (symbol->string sub))
  34.   (string->symbol
  35.    (string-append sub
  36.           (if (string-find? "_" sub) "__" "_"))))
  37.  
  38. (define (si2f2c-stab decl)
  39.   (let* ((context (si-subname decl))
  40.      (common-vars (apply append
  41.                  (map si-common-vars 
  42.                   (si-common decl)))))
  43.     (if (eq? context '*undefined*)
  44.     (set! context (si-filename decl)))
  45.  
  46.     (format #t ";;; Included files:\n")
  47.     (for-each (lambda (inc-file-rec)
  48.        (format #t "(f2c-require '~a)\n"
  49.            (inc->req (si-incs-file-name inc-file-rec))))
  50.      (si-includes decl))
  51.  
  52.     (format #t "\n\n;;; Arguments:\n")
  53.     (for-each (lambda (var-rec)
  54.         (dump-chunk context 'f2c-add-arg-var var-rec))
  55.           (si-args decl))
  56.     
  57.     (format #t "\n\n;;; Local arrays:\n")
  58.     (for-each (lambda (var-rec)
  59.         (if (not (member (si-arg-name var-rec)
  60.                  common-vars))
  61.             (dump-chunk context 'f2c-add-local-var var-rec)))
  62.      (arrays-only (si-locals decl)))
  63.     
  64.     (format #t "\n\n;;; Common blocks:\n")
  65.     (for-each (lambda (common)
  66.            (let ((cname (si-common-name common)))
  67.          (for-each (lambda (cvar)
  68.                 (dump-chunk cname 'f2c-add-common-var
  69.                     (assoc cvar (si-locals decl))))
  70.               (si-common-vars common))
  71.          (format #t "(f2c-add-subcontext '~a '~a)\n"
  72.              context cname)))
  73.          (si-common decl))
  74.  
  75.     (format #t "\n\n;;; Parameters:\n")
  76.     (for-each (lambda (param)
  77.            (format #t "(f2c-add-param '~a  '~a ~s)\n"
  78.                context
  79.                (si-param-name param)
  80.                (si-param-value param)))
  81.          (si-params decl))
  82.  
  83.     (format #t "\n\n;;; Subcontexts (from include files):\n")
  84.     (for-each (lambda (inc-file-rec)
  85.         (format #t "(f2c-add-subcontext '~a '~a)\n"
  86.             context
  87.             (inc->req (si-incs-file-name inc-file-rec))))
  88.           (si-includes decl))))
  89.  
  90. (define (arrays-only l)
  91.   (cond ((null? l) ())
  92.     ((si-arg-dimen (car l))
  93.      (cons (car l)
  94.            (arrays-only (cdr l))))
  95.     (else  (arrays-only (cdr l)))))
  96.  
  97.  
  98. (define (dump-chunk fnam func var-decl)
  99.   (let* ((var (si-arg-name var-decl))
  100.      (dlist (si-arg-dimen var-decl))
  101.      (dimens (if dlist (map string-lower dlist)
  102.              #f))
  103.      (dims (if dimens (si2f2c-stab-aref-convert dimens)
  104.            #f)))
  105.     (if (and dims (not (null? dims)))
  106.     (format #t "(~S '~S '~S '~S '~S)\n"
  107.         func fnam var (list-ref dims 0) (list-ref dims 1))
  108.     (format #t "(~S '~S '~S)\n"
  109.         func fnam var))))
  110.     
  111.  
  112. ;;;(define (si-index-cleaner strng)
  113. ;;;  (define justnum
  114. ;;;    (string->regexp "^[ \t]*[-+]?[0-9]+[ \t]*$"))
  115. ;;;  (define num:num
  116. ;;;    (string->regexp "^[ \t]*([-+]?[0-9]+)[ \t]*:[ \t]*([-+]?[0-9]+)[ \t]*$"))
  117. ;;;  (define expr:expr
  118. ;;;    (string->regexp "^(.*):(.*)$"))
  119. ;;;
  120. ;;;  (let ((match (justnum strng)))
  121. ;;;    (call/cc
  122. ;;;     (lambda (return)
  123. ;;;       (if match
  124. ;;;       (return (list (string->number strng) 1)))
  125. ;;;       (set! match (num:num strng))
  126. ;;;       (if match
  127. ;;;       (return (map string->number
  128. ;;;             (list (apply substring strng (list-ref match 2))
  129. ;;;               (apply substring strng (list-ref match 1))))))
  130. ;;;       (set! match (expr:expr strng))
  131. ;;;       (if match
  132. ;;;        (return (list (apply substring strng (list-ref match 2))
  133. ;;;              (apply substring strng (list-ref match 1)))))
  134. ;;;       (return (list strng 1))))))
  135.  
  136. (define (si-index-cleaner strng)
  137.   (define expr:expr
  138.     (string->regexp "^(.*):(.*)$"))
  139.   (let ((match (expr:expr strng)))
  140.     (if match
  141.     (list (apply substring strng (list-ref match 2))
  142.           (apply substring strng (list-ref match 1)))
  143.     (list strng "1"))))
  144.  
  145. (define (si2f2c-stab-aref-convert dimens)
  146.   (transpose (map si-index-cleaner dimens)))
  147.  
  148. (define (transpose l)
  149.   (cond ((null? l) ())
  150.     ((null? (car l)) ())
  151.     (else (cons (map car l)
  152.             (transpose (map cdr l))))))
  153.  
  154. (provide "si-fstabs-lib")
  155.